home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / modes / xpm-mode.el < prev    next >
Encoding:
Text File  |  1995-07-14  |  14.0 KB  |  440 lines
  1. ;;; xpm-mode.el    --- minor mode for editing XPM files
  2.  
  3. ;; Copyright (C) 1995 Joe Rumsey <ogre@netcom.com>
  4. ;; Copyright (C) 1995 Rich Williams <rdw@hplb.hpl.hp.com>
  5.  
  6. ;; Authors: Joe Rumsey <ogre@netcom.com>
  7. ;;        Rich Williams <rdw@hplb.hpl.hp.com>
  8. ;; Cleanup: Chuck Thompson <cthomp@cs.uiuc.edu>
  9.  
  10. ;; Version:  1.5
  11. ;; Last Modified: Rich Williams <rdw@hplb.hpl.hp.com>, 13 July 1995
  12. ;; Keywords: data tools
  13.  
  14. ;; This file is part of XEmacs.
  15.  
  16. ;; XEmacs is free software; you can redistribute it and/or modify it
  17. ;; under the terms of the GNU General Public License as published by
  18. ;; the Free Software Foundation; either version 2, or (at your option)
  19. ;; any later version.
  20.  
  21. ;; XEmacs is distributed in the hope that it will be useful, but
  22. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  23. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  24. ;; General Public License for more details.
  25.  
  26. ;; You should have received a copy of the GNU General Public License
  27. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  28. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  29.  
  30. ;;
  31. ;; xpm mode:  Display xpm files in color
  32. ;;
  33. ;; thanks to Rich Williams for mods to do this without font-lock-mode,
  34. ;; resulting in much improved performance and a better display
  35. ;; (headers don't get colored strangely). Also for the palette toolbar.
  36. ;;
  37. ;; Non-standard minor mode in that it starts picture-mode automatically.
  38. ;;
  39. ;; To get this turned on automatically for .xpms, add an entry
  40. ;;       ("\\.xpm" . xpm-mode)
  41. ;; to your auto-mode-alist.  For example, my .emacs has this: (abbreviated)
  42. ;; (setq auto-mode-alist (mapcar 'purecopy
  43. ;;                               '(("\\.c$" . c-mode)
  44. ;;                                ("\\.h$" . c-mode)
  45. ;;                                ("\\.el$" . emacs-lisp-mode)
  46. ;;                  ("\\.emacs$" . emacs-lisp-mode)
  47. ;;                                ("\\.a$" . c-mode)
  48. ;;                  ("\\.xpm" . xpm-mode))))
  49. ;; (autoload 'xpm-mode "xpm-mode")
  50. ;;
  51. ;; I am a lisp newbie, practically everything in here I had to look up
  52. ;; in the manual.  It probably shows, suggestions for coding
  53. ;; improvements are welcomed.
  54. ;;
  55. ;; May fail on some xpm's.  Seems to be fine with files generated by
  56. ;; xpaint and ppmtoxpm anyway.  Will definitely fail on xpm's with
  57. ;; more than one character per pixel.  Not that hard to fix, but I've
  58. ;; never seen one like that.
  59. ;;
  60. ;; If your default font is proportional, this will not be very useful.
  61. ;;
  62.  
  63. (require 'annotations)
  64.  
  65. (defvar xpm-pixel-values nil)
  66. (defvar xpm-glyph nil)
  67. (defvar xpm-anno nil)
  68. (defvar xpm-paint-string nil)
  69. (defvar xpm-chars-per-pixel 1)
  70. (defvar xpm-palette nil)
  71. (defvar xpm-always-update-image nil
  72.   "If non-nil, update actual-size image after every click or drag movement.
  73. Otherwise, only update on button releases or when asked to.  This is slow.")
  74.  
  75. (make-variable-buffer-local 'xpm-palette)
  76. (make-variable-buffer-local 'xpm-chars-per-pixel)
  77. (make-variable-buffer-local 'xpm-paint-string)
  78. (make-variable-buffer-local 'xpm-glyph)
  79. (make-variable-buffer-local 'xpm-anno)
  80. (make-variable-buffer-local 'xpm-pixel-values)
  81. ;(make-variable-buffer-local 'xpm-faces-used)
  82.  
  83. (defun xpm-make-face (name)
  84.   "Makes a face with name xpm-NAME, and colour NAME."
  85.   (let ((face (make-face (intern (concat "xpm-" name))
  86.              "Temporary xpm-mode face" t)))
  87.     (set-face-background face name)
  88.     (set-face-foreground face "black")
  89.     face))
  90.  
  91. (defun xpm-init ()
  92.   "Treat the current buffer as an xpm file and colorize it."
  93.   (interactive)
  94.   (require 'picture)
  95.  
  96.   (setq xpm-pixel-values nil)
  97.   (xpm-clear-extents)
  98.   (setq xpm-palette nil)
  99.  
  100.   (message "Finding number of colors...")
  101.   (save-excursion
  102.     (goto-char (point-min))
  103.     (beginning-of-line)
  104.     (next-line 1)
  105.     (while (not (looking-at "\\s-*\""))
  106.       (next-line 1))
  107.     (next-line 1)
  108.     (while (not (looking-at "\\s-*\""))
  109.       (next-line 1))
  110.     (let ((co 0))
  111.       (while (< co (xpm-num-colors))
  112.     (progn
  113.       (xpm-parse-color)
  114.       (setq co (1+ co))
  115.       (next-line 1)
  116.       (beginning-of-line)))))
  117.   (if (not (eq major-mode 'picture-mode))
  118.       (picture-mode))
  119.   (set-specifier left-toolbar-width (cons (selected-frame) 16))
  120.   (set-specifier left-toolbar (cons (current-buffer) xpm-palette))
  121.   (message "Parsing body...")
  122.   (xpm-color-data)
  123.   (message "Parsing body...done")
  124.   (xpm-show-image))
  125.  
  126. (defun xpm-clear-extents ()
  127.   (let (cur-extent
  128.     next-extent)
  129.     (setq cur-extent (next-extent (current-buffer)))
  130.     (setq next-extent (next-extent cur-extent))
  131.     (while cur-extent
  132.       (delete-extent cur-extent)
  133.       (setq cur-extent next-extent)
  134.       (setq next-extent (next-extent cur-extent)))))
  135.  
  136. (defun xpm-color-data ()
  137.   (interactive)
  138.   (save-excursion
  139.     (xpm-goto-body-line 0)
  140.     (let (ext
  141.       pixel-chars
  142.       pixel-color)
  143.       (while (< (point) (point-max))
  144.     (setq pixel-chars
  145.           (buffer-substring (point) (+ (point) xpm-chars-per-pixel))
  146.           pixel-color (assoc pixel-chars xpm-pixel-values)
  147.           ext (make-extent (point) (+ (point) xpm-chars-per-pixel)))
  148.     (if pixel-color
  149.         (progn
  150.           (set-extent-face ext (cdr pixel-color)))
  151.       (set-extent-face ext 'default))
  152.     (forward-char xpm-chars-per-pixel)))))
  153.  
  154. (defun xpm-num-colors ()
  155.   (save-excursion
  156.     (goto-char (point-min))
  157.     (if (re-search-forward 
  158.      "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-*"
  159.      (point-max) t)
  160.     (string-to-int (match-string 3))
  161.       (error "Unable to parse xpm information"))))
  162.  
  163. (defun xpm-make-solid-pixmap (colour width height)
  164.   (let ((x 0)
  165.     (y 0)
  166.     (line nil)
  167.     (total nil))
  168.     (setq line ",\n\"")
  169.     (while (< x width)
  170.       (setq line (concat line ".")
  171.         x (+ x 1)))
  172.     (setq line (concat line "\"")
  173.       total (format "/* XPM */\nstatic char * %s[] = {\n\"%d %d 1 1\",\n\". c %s\""
  174.             colour width height colour))
  175.     (while (< y height)
  176.       (setq total (concat total line)
  177.         y (+ y 1)))
  178.     (make-glyph (concat total "};\n"))))
  179.  
  180. (defun xpm-store-color (str color)
  181.   "Add STR to xpm-pixel-values with a new face set to background COLOR
  182. if STR already has an entry, the existing face will be used, with the
  183. new color replacing the old (on the display only, not in the xpm color
  184. defs!)"
  185.   (let (new-face)
  186.     (setq new-face (xpm-make-face color))
  187.     (set-face-background new-face color)
  188.     (let ((ccc (color-rgb-components (make-color-specifier color))))
  189.       (if (> (length ccc) 0)
  190.       (if (or (or (> (elt ccc 0) 32767)
  191.               (> (elt ccc 1) 32767))
  192.           (> (elt ccc 2) 32767))
  193.           (set-face-foreground new-face "black")
  194.         (set-face-foreground new-face "white"))))
  195.     (setq xpm-pixel-values (cons (cons str new-face) xpm-pixel-values)
  196.       xpm-palette
  197.       (cons (vector 
  198.          (list (xpm-make-solid-pixmap color 12 12))
  199.          ;; Major cool things with quotes.....
  200.          (` 
  201.           (lambda (event)
  202.             (interactive "e")
  203.             (xpm-toolbar-select-colour event (, str))))
  204.          t
  205.          color) xpm-palette))
  206.     ))
  207.  
  208. (defun xpm-parse-color ()
  209.   "Parse xpm color string from current line and set the color"
  210.   (interactive)
  211.   (let (end)
  212.     (save-excursion
  213.       (end-of-line)
  214.       (setq end (point))
  215.       (beginning-of-line)
  216.       (if (re-search-forward
  217.        ;; Generate a regexp on the fly
  218.        (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\)" ; chars
  219.            "\\s-+\\([c]\\)"    ; there are more classes than 'c'
  220.            "\\s-+\\([^\"]+\\)\"")
  221.        end t)
  222.       (progn 
  223.         (xpm-store-color (match-string 1) (match-string 3))
  224.         (list (match-string 1) (match-string 3)))
  225.     (error "Unable to parse color")))))
  226.  
  227. (defun xpm-add-color (str color)
  228.   "add a color to an xpm's list of color defs"
  229.   (interactive "sPixel character: 
  230. sPixel color (any valid X color string):")
  231.   (save-excursion
  232.     (goto-char (point-min))
  233.     (while (not (looking-at "\\s-*\""))
  234.       (next-line 1))
  235.     (next-line 1)
  236.     (while (not (looking-at "\\s-*\""))
  237.       (next-line 1))
  238.     (let ((co 0))
  239.       (while (< co (xpm-num-colors))
  240.     (next-line 1)
  241.     (setq co (1+ co))))
  242.     (insert (format "\"%s\tc %s\",\n" str color))
  243.     (previous-line 1)
  244.     (xpm-parse-color)
  245.  
  246.     (goto-char (point-min))
  247.     (while (not (looking-at "\\s-*\""))
  248.       (next-line 1))
  249.     (let ((entry 0))
  250.       (while (or (= (char-after (point)) ? ) (= (char-after (point)) ?\"))
  251.     (forward-char 1))
  252.       (while (< entry 2)
  253.     (progn
  254.       (if (eq (char-after (point)) ? )
  255.           (progn
  256.         (setq entry (1+ entry))
  257.         (while (eq (char-after (point)) ? )
  258.           (forward-char 1)))
  259.         (forward-char 1))))
  260.       (let ((old-colors (xpm-num-colors)))
  261.     (while (and (>= (char-after (point)) ?0) (<= (char-after (point)) ?9))
  262.       (delete-char 1))
  263.       (insert (int-to-string (1+ old-colors)))))))
  264.  
  265.  
  266. (defun xpm-goto-color-def (def)
  267.   "move to color DEF in the xpm header"
  268.   (interactive "nColor number:")
  269.   (goto-char (point-min))
  270.   (while (not (looking-at "\\s-*\""))
  271.     (next-line 1))
  272.   (next-line 1)
  273.   (while (not (looking-at "\\s-*\""))
  274.     (next-line 1))
  275.   (next-line def))
  276.  
  277. (defun xpm-goto-body-line (line)
  278.   "move to LINE lines down from the start of the body of an xpm"
  279.   (interactive "nBody line:")
  280.   (goto-char (point-min))
  281.   (xpm-goto-color-def (xpm-num-colors))
  282.   (next-line line))
  283.  
  284. (defun xpm-show-image ()
  285.   "Display the xpm in the current buffer at the end of the topmost line"
  286.   (interactive)
  287.   (save-excursion
  288.     (if (annotationp xpm-anno)
  289.     (delete-annotation xpm-anno))
  290.     (setq xpm-glyph (make-glyph 
  291.              (vector 'xpm :data 
  292.                  (buffer-substring (point-min) (point-max)))))
  293.     (goto-char (point-min))
  294.     (end-of-line)
  295.     (setq xpm-anno (make-annotation xpm-glyph (point) 'text))))
  296.  
  297. (defun xpm-hide-image ()
  298.   "Remove the image of the xpm from the buffer"
  299.   (interactive)
  300.   (if (annotationp xpm-anno)
  301.       (delete-annotation xpm-anno)))
  302.  
  303. (defun xpm-in-body ()
  304.   (let ((p (point)))
  305.     (save-excursion
  306.       (xpm-goto-body-line 0)
  307.       (> p (point)))))
  308.  
  309. (defvar xpm-mode nil)
  310. (make-variable-buffer-local 'xpm-mode)
  311. (add-minor-mode 'xpm-mode " XPM" nil)
  312. (defvar xpm-mode-map (make-keymap))
  313.  
  314. (defun xpm-toolbar-select-colour (event chars)
  315.   "Toolbar button"
  316.   (let* ((button (event-toolbar-button event))
  317.      (help (toolbar-button-help-string button)))
  318.     (message "Toolbar selected %s (%s)"  help chars)
  319.     (setq xpm-palette
  320.       (mapcar #'(lambda (but)
  321.               (aset but 2 (not (eq help (aref but 3))))
  322.               but)
  323.           xpm-palette)
  324.       xpm-paint-string chars)
  325.     (set-specifier left-toolbar (cons (current-buffer) xpm-palette))))
  326.  
  327. (defun xpm-mouse-paint (event)
  328.   (interactive "e")
  329.   (mouse-set-point event)
  330.   (if (xpm-in-body)
  331.       ;; in body, overwrite the paint string where the mouse is clicked
  332.       (progn
  333.     (insert xpm-paint-string)
  334.     (delete-char (length xpm-paint-string)))
  335.     ;; otherwise, select the color defined by the line where the mouse
  336.     ;; was clicked
  337.     (save-excursion
  338.       (beginning-of-line)
  339.       (forward-char 1)
  340.       (setq xpm-paint-string (buffer-substring (point) (1+ (point)))))))
  341.  
  342. (defun xpm-mouse-down (event n)
  343. ;  (interactive "ep")
  344.   (mouse-set-point event)
  345.   (if (xpm-in-body)
  346.       ;; in body, overwrite the paint string where the mouse is clicked
  347.       (progn
  348.     (insert xpm-paint-string)
  349.     (delete-char (length xpm-paint-string))
  350.     (if xpm-always-update-image
  351.         (xpm-show-image))
  352.     (let ((ext (make-extent (1- (point))
  353.                 (+ (1- (point)) xpm-chars-per-pixel)))
  354.           (pixel-color (assoc xpm-paint-string xpm-pixel-values)))
  355.       (if pixel-color
  356.           (set-extent-face ext (cdr pixel-color))
  357.         (set-extent-face ext 'default))))
  358.     ;; otherwise, select the color defined by the line where the mouse
  359.     ;; was clicked
  360.     (save-excursion
  361.       (beginning-of-line)
  362.       (forward-char 1)
  363.       (setq xpm-paint-string (buffer-substring (point) (1+ (point)))))))
  364.  
  365. (defun xpm-mouse-drag (event n timeout)
  366.   (or timeout
  367.       (progn
  368.     (mouse-set-point event)
  369.     (if (xpm-in-body)
  370.         ;; Much improved by not using font-lock-mode
  371.         (or (string= xpm-paint-string
  372.              (buffer-substring (point)
  373.                        (+ (length xpm-paint-string)
  374.                           (point))))
  375.         (progn
  376.           (insert-char (string-to-char xpm-paint-string) 1)
  377.                     ;      (insert xpm-paint-string)
  378.           (delete-char (length xpm-paint-string))
  379.           (if xpm-always-update-image
  380.               (xpm-show-image))
  381.           (let ((ext (make-extent
  382.                   (1- (point))
  383.                   (+ (1- (point)) xpm-chars-per-pixel)))
  384.             (pixel-color
  385.              (assoc xpm-paint-string xpm-pixel-values)))
  386.             (if pixel-color
  387.             (set-extent-face ext (cdr pixel-color))
  388.               (set-extent-face ext 'default)))))))))
  389.  
  390. (defun xpm-mouse-up (event n)
  391.   (xpm-show-image))
  392.  
  393. ;;;###autoload
  394. (defun xpm-mode (&optional arg)
  395.   "Treat the current buffer as an xpm file and colorize it.
  396.  
  397.   Shift-button-1 lets you paint by dragging the mouse.  Shift-button-1 on a
  398. color definition line will change the current painting color to that line's
  399. value.
  400.  
  401.   Characters inserted from the keyboard will NOT be colored properly yet.
  402. Use the mouse, or do xpm-init (\\[xpm-init]) after making changes.
  403.  
  404. \\[xpm-add-color] Add a new color, prompting for character and value
  405. \\[xpm-show-image] show the current image at the top of the buffer
  406. \\[xpm-parse-color] parse the current line's color definition and add
  407.    it to the color table.  Provided as a means of changing colors.
  408. XPM minor mode bindings:
  409. \\{xpm-mode-map}"
  410.  
  411.   (interactive "P")
  412.   (setq xpm-mode
  413.     (if (null arg) (not xpm-mode)
  414.       (> (prefix-numeric-value arg) 0)))
  415.   (if xpm-mode
  416.       (progn
  417.     (xpm-init)
  418.     (make-local-variable 'mouse-track-down-hook)
  419.     (make-local-variable 'mouse-track-drag-hook)
  420.     (make-local-variable 'mouse-track-up-hook)
  421.     (make-local-variable 'mouse-track-drag-up-hook)
  422.     (make-local-variable 'mouse-track-click-hook)
  423.     (setq mouse-track-down-hook 'xpm-mouse-down)
  424.     (setq mouse-track-drag-hook 'xpm-mouse-drag)
  425.     (setq mouse-track-up-hook 'xpm-mouse-up)
  426.     (setq mouse-track-drag-up-hook 'xpm-mouse-up)
  427.     (setq mouse-track-click-hook nil)
  428.     (or (assq 'xpm-mode minor-mode-map-alist)
  429.         (progn
  430.           (define-key xpm-mode-map [(control c) r] 'xpm-show-image)
  431.           (define-key xpm-mode-map [(shift button1)] 'mouse-track)
  432.           (define-key xpm-mode-map [button1] 'mouse-track-default)
  433.           (define-key xpm-mode-map [(control c) c] 'xpm-add-color)
  434.           (define-key xpm-mode-map [(control c) p] 'xpm-parse-color)
  435.           (setq minor-mode-map-alist (cons (cons 'xpm-mode xpm-mode-map)
  436.                            minor-mode-map-alist)))))))
  437.  
  438. (provide 'xpm-mode)
  439. ;;; xpm-mode.el ends here
  440.